home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 22
/
Cream of the Crop 22.iso
/
program
/
tdk_v120.zip
/
EXEC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-07-15
|
37KB
|
1,193 lines
{
▀▀▀▀▀▀▀▀ ▀▀▀▀▀▀ ▀▀ ▀▀
▀▀ ▀▀ ▀▀ ▀▀ ▀▀
▀▀ ▀▀ ▀▀▀ ▀▀▀▀▀ The DoorKit!
▀▀ ▀▀ ▀▀ ▀▀ ▀▀
▀▀ ▀▀▀▀▀▀ ▀▀ ▀▀
The BBS Door Development Kit By The People - For The People!
Feel free to modify or optimize this code at will. All I ask is that if
find a better way to do things (and you will), please send me a copy of
your modifications. Thanks in advance!....Larry L. Athey....}
Unit EXEC;
{ --- Version 3.3 93-06-22 14:45 ---
EXEC.PAS: EXEC function with memory swap - prepare parameters.
Needs Assembler file 'spawn.asm' (assembled as 'spawnp.obj')
and unit 'checkpat'.
Public domain software by
Thomas Wagner
Ferrari electronic GmbH
Beusselstrasse 27
D-1000 Berlin 21
West Germany
BIXname: twagner
}
INTERFACE
Uses
DOS, checkpat;
CONST
{e Return codes (only upper byte significant) }
{d Fehlercodes (nur das obere Byte signifikant) }
RC_PREPERR = $0100;
RC_NOFILE = $0200;
RC_EXECERR = $0300;
RC_ENVERR = $0400;
RC_SWAPERR = $0500;
RC_REDIRERR = $0600;
{e Swap method and option flags }
{d Auslagerungsmethoden ond Optionen }
USE_EMS = $01;
USE_XMS = $02;
USE_FILE = $04;
EMS_FIRST = $00;
XMS_FIRST = $10;
HIDE_FILE = $40;
NO_PREALLOC = $100;
CHECK_NET = $200;
USE_ALL = USE_EMS OR USE_XMS OR USE_FILE OR CHECK_NET;
TYPE
filename = STRING [81];
string128 = STRING [128];
pstring = ^STRING;
FUNCTION do_exec (xfn : STRING; pars : STRING; spawn : INTEGER;
needed : WORD; newenv : BOOLEAN) : INTEGER;
{>e
The EXEC function.
Parameters:
xfn is a string containing the name of the file
to be executed. If the string is empty,
the COMSPEC environment variable is used to
load a copy of COMMAND.COM or its equivalent.
If the filename does not include a path, the
current PATH is searched after the default.
If the filename does not include an extension,
the path is scanned for a COM, EXE, or BAT file
in that order.
pars The program parameters.
spawn If 0, the function will terminate after the
EXECed program returns, the function will not return.
NOTE: If the program file is not found, the function
will always return with the appropriate error
code, even if 'spawn' is 0.
If non-0, the function will return after executing the
program. If necessary (see the "needed" parameter),
memory will be swapped out before executing the program.
For swapping, spawn must contain a combination of the
following flags:
USE_EMS ($01) - allow EMS swap
USE_XMS ($02) - allow XMS swap
USE_FILE ($04) - allow File swap
The order of trying the different swap methods can be
controlled with one of the flags
EMS_FIRST ($00) - EMS, XMS, File (default)
XMS_FIRST ($10) - XMS, EMS, File
If swapping is to File, the attribute of the swap file
can be set to "hidden", so users are not irritated by
strange files appearing out of nowhere with the flag
HIDE_FILE ($40) - create swap file as hidden
and the behaviour on Network drives can be changed with
NO_PREALLOC (0x100) - don't preallocate
CHECK_NET (0x200) - don't preallocate if file on net.
This checking for Network is mainly to compensate for
a strange slowdown on Novell networks when preallocating
a file. You can either set NO_PREALLOC to avoid allocation
in any case, or let the prep_swap routine decide whether
to do preallocation or not depending on the file being
on a network drive (this will only work with DOS 3.1 or
later).
needed The memory needed for the program in paragraphs (16 Bytes).
If not enough memory is free, the program will
be swapped out.
Use 0 to never swap, $ffff to always swap.
If 'spawn' is 0, this parameter is irrelevant.
newenv If this parameter is FALSE, the environment
of the spawned program is a copy of the parent's
environment. If it is TRUE, a new environment
is created which includes the modifications from
previous 'putenv' calls.
Return value:
$0000..00FF: The EXECed Program's return code
$0101: Error preparing for swap: no space for swapping
$0102: Error preparing for swap: program too low in memory
$0200: Program file not found
$0201: Program file: Invalid drive
$0202: Program file: Invalid path
$0203: Program file: Invalid name
$0204: Program file: Invalid drive letter
$0205: Program file: Path too long
$0206: Program file: Drive not ready
$0207: Batchfile/COMMAND: COMMAND.COM not found
$0208: Error allocating temporary buffer
$03xx: DOS-error-code xx calling EXEC
$0400: Error allocating environment buffer
$0500: Swapping requested, but prep_swap has not
been called or returned an error.
$0501: MCBs don't match expected setup
$0502: Error while swapping out
$0600: Redirection syntax error
$06xx: DOS error xx on redirection
<}
{>d
Die EXEC Funktion.
Parameter:
xfn ist ein String mit dem Namen der auszuführenden Datei.
Ist der String leer, wird die COMSPEC Umgebungsvariable
benutzt um COMMAND.COM oder das Equivalent zu laden.
Ist kein Pfad angegeben, wird nach dem aktuellen Pfad
der in der PATH Umgebungsvariablen angegebene Pfad
durchsucht.
Ist kein Dateityp angegeben, wird der Pfad nach
einer COM oder EXE Datei (in dieser Reihenfolge) abgesucht.
pars Die Kommandozeile
spawn Wenn 0, wird der Programmlauf beendet wenn das
aufgerufene Programm zurückkehrt, die Funktion kehrt
nicht zurück.
HINWEIS: Wenn die auszuführende Datei nicht gefunden
wird, kehrt die Funktion mit einem Fehlercode
zurück, auch wenn der 'spawn' Parameter 0 ist.
Wenn nicht 0, kehrt die Funktion nach Ausführung des
Programms zurück. Falls notwendig (siehe den Parameter
"needed") wird der Programmspeicherbereich vor Aufruf
ausgelagert.
Zur Auslagerung muß der Parameter eine Kombination der
folgenden Flags enthalten:
USE_EMS ($01) - Auslagerung auf EMS zulassen
USE_XMS ($02) - Auslagerung auf XMS zulassen
USE_FILE ($04) - Auslagerung auf Datei zulassen
Die Reihenfolge der Versuche, auf die verschiedenen
Medien auszulagern kann mit einem der folgenden
Flags beeinflußt werden:
EMS_FIRST ($00) - EMS, XMS, Datei (Standard)
XMS_FIRST ($10) - XMS, EMS, Datei
Wenn die Auslagerung auf Datei erfolgt, kann das
Attribut dieser Datei auf "hidden" gesetzt werden,
damit der Benutzer nicht durch unversehends auftauchende
Dateien verwirrt wird:
HIDE_FILE ($40) - Auslagerungsdatei "hidden" erzeugen
Außerdem kann das Verhalten auf Netzwerk-Laufwerken
beeinflußt werden mit
NO_PREALLOC (0x100) - nicht Präallozieren
CHECK_NET (0x200) - nicht Präallozieren wenn Netz.
Diese Prüfung auf Netzwerk ist hauptsächlich sinnvoll
für Novell Netze, bei denen eine Präallozierung eine
erhebliche Verzögerung bewirkt. Sie können entweder mit
NO_PREALLOC eine Präallozierung in jedem Fall ausschließen,
oder die Entscheidung mit CHECK_NET prep_swap überlassen.
In diesem Fall wird nicht präalloziert wenn die Datei
auf einem Netzwerk-Laufwerk liegt (funktioniert nur
mit DOS Version 3.1 und späteren).
needed Der zur Ausführung des Programms benötigte Speicher
in Paragraphen (16 Bytes). Wenn nicht ausreichend
freier Speicher vorhanden ist, wird der Programm-
speicherbereich ausgelagert.
Bei Angabe von 0 wird nie ausgelagert, bei Angabe
von $ffff wird immer ausgelagert.
Ist der Parameter 'spawn' 0, hat 'needed' keine Bedeutung.
newenv Bestimmt die dem gerufenen Programm zu übergebenden
Umgebungsvariablen. Ist der Parameter FALSE,
wird eine Kopie der Vater-Umgebung benutzt,
d.h. daß Aufrufe von "putenv" keinen Effekt haben.
Ist er TRUE, wird eine neue Umgebung mit den
Modifikationen aus 'putenv' übergeben.
Liefert:
$0000..00FF: Rückgabewert des aufgerufenen Programms
$0101: Fehler bei Vorbereitung zum Auslagern -
kein Speicherplatz in XMS/EMS/Datei
$0102: Fehler bei Vorbereitung zum Auslagern -
der Programmcode ist zu nah am Beginn des
Programms.
$0200: Auszuführende Programmdatei nicht gefunden
$0201: Programmdatei: Ungültiges Laufwerk
$0202: Programmdatei: Ungültiger Pfad
$0203: Programmdatei: Ungültiger Dateiname
$0204: Programmdatei: Ungültiger Laufwerksbuchstabe
$0205: Programmdatei: Pfad zu lang
$0206: Programmdatei: Laufwerk nicht bereit
$0207: Batchfile/COMMAND: COMMAND.COM nicht gefunden
$0208: Fehler beim allozieren eines temporären Puffers
$03xx: DOS-Fehler-Code xx bei Aufruf von EXEC
$0400: Fehler beim allozieren der Umgebungsvariablenkopie
$0500: Auslagerung angefordert, aber prep_swap wurde nicht
aufgerufen oder lieferte einen Fehler
$0501: MCBs entsprechen nicht dem erwarteten Aufbau
$0502: Fehler beim Auslagern
$0600: Redirection Syntaxfehler
$06xx: DOS-Fehler xx bei Redirection
<}
{>e
The function pointed to by "spawn_check" will be called immediately
before doing the actual swap/exec, provided that
- the preparation code did not detect an error, and
- "spawn_check" is not NIL.
The function definition is
function name (cmdbat: integer; swapping: integer; var execfn: string;
var progpars: string): integer;
The parameters passed to this function are
cmdbat 1: Normal EXE/COM file
2: Executing BAT file via COMMAND.COM
3: Executing COMMAND.COM (or equivalent)
swapping < 0: Exec, don't swap
0: Spawn, don't swap
> 0: Spawn, swap
execfn the file name to execute (complete with path)
progpars the program parameter string
If the routine returns anything other than 0, the swap/exec will
not be executed, and do_exec will return with this code.
You can use this function to output messages (for example, the
usual "enter EXIT to return" message when loading COMMAND.COM)
and to do clean-up and additional checking.
CAUTION: If swapping is > 0, the routine may not modify the
memory layout, i.e. it may not call any memory allocation or
deallocation routines.
"spawn_check" is initialized to NIL.
<}
{>d
Die Funktion auf die "spawn_check" zeigt wird unmittelbar vor
Ausführung des Programmaufrufs aufgerufen, vorausgesetzt daß
- bei der Vorbereitung kein Fehler auftrat, und
- "spawn_check" nicht NIL ist.
Die Funktionsdefinition ist
function name (cmdbat: integer; swapping: integer; var execfn: string;
var progpars: string): integer;
Die der Funktion übergebenen Parameter sind
cmdbat 1: Normale EXE/COM Datei
2: Ausführung BAT Datei über COMMAND.COM
3: Ausführung COMMAND.COM (oder Equivalent)
swapping < 0: Exec, keine Auslagerung
0: Spawn, keine Auslagerung
> 0: Spawn, Auslagern
execfn Name und Pfad der auszuführenden Datei
progpars Programmparameter
Wenn die Routine einen Wert verschieden von 0 liefert, wird der
Programmaufruf nicht durchgeführt, und do_exec kehrt mit diesem
Wert zurück.
Sie können diese Funktion benutzen um Meldungen auszugeben
(zum Beispiel die übliche Meldung "Geben Sie EXIT ein um
zurückzukehren" bei Laden von COMMAND.COM), und für sonstige
Prüfungen oder Aufräumarbeiten.
ACHTUNG: Wenn swapping > 0 ist, darf die Funktion keinesfalls
den Speicheraufbau verändern, d.h. es dürfen keine Speicher-
Allozierungs oder -Deallozierungsroutinen benutzt werden.
"spawn_check" ist auf NIL initialisiert.
<}
TYPE
spawn_check_proc = FUNCTION (cmdbat : INTEGER; swapping : INTEGER;
VAR execfn : STRING; VAR progpars : STRING)
: INTEGER;
VAR
spawn_check : spawn_check_proc;
{>e
The 'swap_prep' variable can be accessed from the spawn_check
call-back routine for additional information on the nature and
parameters of the swap. This variable will ONLY hold useful
information if the 'swapping' parameter to spawn_check is > 0.
The contents of this variable may not be changed.
The 'swapmethod' field will contain one of the flags USE_FILE,
USE_XMS, or USE_EMS.
Note that the 'swapfilename' field contains a zero-terminated string
with no prefixed length byte, not a Pascal string.
<}
{>d
Die Variable 'swap_prep' kann von der spawn_check Routine
benutzt werden um zusätzliche Informationen über Art und Parameter
der Auslagerung zu erfahren. Diese Variable enthält NUR DANN
sinnvolle Werte wenn der 'swapping' Parameter von spawn_check > 0 ist.
Der Inhalt dieser Variablen darf keinesfalls verändert werden.
Das Feld 'swapmethod' enthält einen der Werte USE_FILE,
USE_XMS, oder USE_EMS.
Bitte beachten Sie, daß das Feld 'swapfilename' einen Null-terminierten
String ohne Längenbyte, keinen Pascal-String, enthält.
<}
TYPE
prep_block = RECORD
xmm : LONGINT; {e XMM entry address }
{d Einsprungadresse XMM }
first_mcb : INTEGER; {e Segment of first MCB }
{d Segment des ersten MCB }
psp_mcb : INTEGER; {e Segment of MCB of our PSP }
{d Segment des MCB unseres PSP }
env_mcb : INTEGER; {e MCB of Environment segment }
{d MCB des Umgebungsvariablenblocks }
noswap_mcb : INTEGER; {e MCB that may not be swapped }
{d MCB der nicht Ausgelagert wird }
ems_pageframe : INTEGER; {e EMS page frame address }
{d EMS-Seiten-Adresse }
handle : INTEGER; {e EMS/XMS/File handle }
{d Handle für EMS/XMS/Datei }
total_mcbs : INTEGER; {e Total number of MCBs }
{d Gesamtzahl MCBs }
swapmethod : BYTE; {e Method for swapping }
{d Auslagerungsmethode }
swapfilename : ARRAY [0..80] OF CHAR;
{e Swap file name if swapping to file }
{d Auslagerungsdateiname }
END;
VAR
swap_prep : prep_block;
{ ------------------------------------------------------------------------- }
PROCEDURE putenv (envvar : STRING);
{ Adds a string to the environment. Note that the change to the
environment is valid for an exec'ed process only, and only if you
set the 'newenv' parameter in do_exec to TRUE. }
FUNCTION envcount : INTEGER;
FUNCTION envstr (index : INTEGER) : STRING;
FUNCTION getenv (envvar : STRING) : STRING;
{ Replacement functions for the environment handling functions in the
DOS unit. All three functions work exactly like their DOS-unit
counterparts, except that they recognize the changes to the child
environment produced by 'putenv'. }
{===========================================================================}
IMPLEMENTATION
{>e
Define REDIRECT to support redirection.
CAUTION: The definition in 'spawn.asm' must match this definition!!
<}
{>d
Definieren Sie REDIRECT um Dateiumleitung zu untertützen.
ACHTUNG: Die Definition in 'spawn.asm' muß mit dieser Definition
übereinstimmen!!
<}
{$DEFINE REDIRECT}
CONST
swap_filename = '$$AAAAAA.AAA';
{e internal flags for prep_swap }
{d interne Flags für prep_swap }
CREAT_TEMP = $0080;
DONT_SWAP_ENV = $4000;
ERR_COMSPEC = - 7;
ERR_NOMEM = - 8;
spaces : SET OF #9..' ' = [#9, ' '];
TYPE
stringptr = ^STRING;
stringarray = ARRAY [0..10000] OF stringptr;
stringarrptr = ^stringarray;
bytearray = ARRAY [0..30000] OF BYTE;
bytearrayptr = ^bytearray;
VAR
envptr : stringarrptr; { Pointer to the changed environment }
envcnt : INTEGER; { Count of environment strings }
cmdpath : STRING;
cmdpars : STRING;
drive : STRING [3];
dir : STRING [67];
name : STRING [9];
ext : STRING [5];
{$L spawnp}
FUNCTION do_spawn (swapping : INTEGER;
VAR xeqfn; VAR cmdtail; envlen : WORD;
VAR env
{$IFDEF REDIRECT}
;stdin : pstring; stdout : pstring; stderr : pstring
{$ENDIF}
) : INTEGER; EXTERNAL;
FUNCTION prep_swap (method : INTEGER; VAR swapfn) : INTEGER; EXTERNAL;
{ helper routine }
FUNCTION strpbrk (par, pattern : STRING) : INTEGER;
{ find position of any one of the characters in 'pattern' in string 'par' }
VAR
i : INTEGER;
BEGIN
FOR i := 1 TO LENGTH (par) DO
IF POS (par [i], pattern) > 0
THEN BEGIN
strpbrk := i;
EXIT;
END;
strpbrk := 0;
END;
{ Environment routines }
FUNCTION envcount : INTEGER;
{ Returns count of strings in environment. }
VAR
cnt : INTEGER;
BEGIN
IF envptr = NIL { If not yet changed }
THEN envcount := DOS.envcount
ELSE envcount := envcnt;
END;
FUNCTION envstr (index : INTEGER) : STRING;
{ Returns environment string 'index' }
BEGIN
IF envptr = NIL { If not yet changed }
THEN envstr := DOS.envstr (index)
ELSE IF (index <= 0) OR (index >= envcnt)
THEN envstr := ''
ELSE IF envptr^ [index - 1] = NIL
THEN envstr := ''
ELSE envstr := envptr^ [index - 1]^;
END;
FUNCTION name_eq (VAR n1, n2 : STRING) : BOOLEAN;
{ Compares search string 'n1' with environment string 'n2'.
Case is insignificant. }
VAR
i : INTEGER;
eq : BOOLEAN;
BEGIN
i := 1;
eq := FALSE;
WHILE (i <= LENGTH (n1)) AND (i <= LENGTH (n2)) AND
(UPCASE (n1 [i]) = UPCASE (n2 [i])) DO
i := i + 1;
name_eq := (i > LENGTH (n1)) AND (i <= LENGTH (n2)) AND (n2 [i] = '=');
END;
FUNCTION searchenv (VAR STR : STRING) : INTEGER;
{ Search for environment string, returns index in 'envptr' array.
Assumes 'envptr' is not NIL. }
VAR
idx : INTEGER;
found : BOOLEAN;
BEGIN
idx := 0;
found := FALSE;
WHILE (idx < envcnt) AND NOT found DO
BEGIN
IF envptr^ [idx] <> NIL
THEN found := name_eq (STR, envptr^ [idx]^);
idx := idx + 1;
END;
IF NOT found
THEN searchenv := - 1
ELSE searchenv := idx - 1;
END;
FUNCTION getenv (envvar : STRING) : STRING;
{ Returns value of environment string specified by name. }
VAR
strp : stringptr;
eq : INTEGER;
BEGIN
IF envptr = NIL { If not yet changed }
THEN getenv := DOS.getenv (envvar)
ELSE BEGIN
eq := searchenv (envvar);
IF eq < 0
THEN getenv := ''
ELSE BEGIN
strp := envptr^ [eq];
eq := POS ('=', strp^);
getenv := COPY (strp^, eq + 1, LENGTH (strp^) - eq);
END;
END;
END;
PROCEDURE init_envptr;
{ Initialise 'envptr' array. Called when 'putenv' is used for the
first time. Copies all environment strings into heap storage,
and builds an array of pointers to this strings. }
VAR
i : INTEGER;
STR : STRING [255];
BEGIN
envcnt := DOS.envcount;
GETMEM (envptr, envcnt * SIZEOF (stringptr));
IF envptr = NIL
THEN EXIT;
FOR i := 0 TO envcnt - 1 DO
BEGIN
STR := DOS.envstr (i + 1);
GETMEM (envptr^ [i], LENGTH (STR) + 1);
IF envptr^ [i] <> NIL
THEN envptr^ [i]^ := STR;
END;
END;
PROCEDURE putenv (envvar : STRING);
{ Adds the string 'envvar' to the environment, or changes the
environment string if the name is already present. }
VAR
idx, eq : INTEGER;
help : stringarrptr;
tmpvar : STRING;
BEGIN
IF envptr = NIL
THEN init_envptr;
IF envptr = NIL
THEN EXIT;
eq := POS ('=', envvar);
IF eq = 0
THEN EXIT;
FOR idx := 1 TO eq DO
envvar [idx] := UPCASE (envvar [idx]);
tmpvar := COPY (envvar, 1, eq - 1); { Copy the portion up to "=" }
idx := searchenv (tmpvar);
IF idx >= 0
THEN BEGIN
FREEMEM (envptr^ [idx], LENGTH (envptr^ [idx]^) + 1);
IF eq >= LENGTH (envvar)
THEN envptr^ [idx] := NIL
ELSE BEGIN
GETMEM (envptr^ [idx], LENGTH (envvar) + 1);
IF envptr^ [idx] <> NIL
THEN envptr^ [idx]^ := envvar;
END;
END
ELSE IF eq < LENGTH (envvar)
THEN BEGIN
GETMEM (help, (envcnt + 1) * SIZEOF (stringptr));
IF help = NIL
THEN EXIT;
MOVE (envptr^, help^, envcnt * SIZEOF (stringptr));
FREEMEM (envptr, envcnt * SIZEOF (stringptr));
envptr := help;
GETMEM (envptr^ [envcnt], LENGTH (envvar) + 1);
IF envptr^ [envcnt] <> NIL
THEN envptr^ [envcnt]^ := envvar;
envcnt := envcnt + 1;
END;
END;
{ Routines to search for files }
FUNCTION tryext (VAR fn : STRING) : INTEGER;
{ Try '.COM', '.EXE', and '.BAT' on current filename, modify filename if found. }
VAR
nfn : filename;
ok : BOOLEAN;
BEGIN
tryext := 1;
nfn := fn + '.COM';
ok := exists (nfn);
IF NOT ok
THEN BEGIN
nfn := fn + '.EXE';
ok := exists (nfn);
END;
IF NOT ok
THEN BEGIN
tryext := 2;
nfn := fn + '.BAT';
ok := exists (nfn);
END;
IF NOT ok
THEN tryext := 0
ELSE fn := nfn;
END;
FUNCTION findfile (VAR fn : STRING) : INTEGER;
{ Try to find the file 'fn' in the current path. Modifies the filename
accordingly. }
VAR
path : STRING;
i, j : INTEGER;
hasext, found, check : INTEGER;
BEGIN
IF fn = ''
THEN BEGIN
IF cmdpath = ''
THEN findfile := ERR_COMSPEC
ELSE findfile := 3;
EXIT;
END;
check := checkpath (fn, INF_NODIR, drive, dir, name, ext, fn);
IF check < 0
THEN BEGIN
findfile := check;
EXIT;
END;
IF ((check AND HAS_WILD) <> 0) OR ((check AND HAS_FNAME) = 0)
THEN BEGIN
findfile := ERR_FNAME;
EXIT;
END;
IF (check AND HAS_EXT) <> 0
THEN BEGIN
FOR i := 1 TO LENGTH (ext) DO
ext [i] := UPCASE (ext [i]);
IF ext = '.BAT'
THEN hasext := 2
ELSE hasext := 1;
END
ELSE hasext := 0;
IF hasext <> 0
THEN BEGIN
IF (check AND FILE_EXISTS) <> 0
THEN found := hasext
ELSE found := 0;
END
ELSE found := tryext (fn);
IF (found <> 0) OR ((check AND (HAS_PATH OR HAS_DRIVE)) <> 0)
THEN BEGIN
findfile := found;
EXIT;
END;
path := getenv ('PATH');
i := 1;
WHILE (found = 0) AND (i <= LENGTH (path)) DO
BEGIN
j := 0;
WHILE (path [i] <> ';') AND (i <= LENGTH (path)) DO
BEGIN
j := j + 1;
fn [j] := path [i];
i := i + 1;
END;
i := i + 1;
IF (j > 0)
THEN BEGIN
IF NOT (fn [j] IN ['\', '/'])
THEN BEGIN
j := j + 1;
fn [j] := '\';
END;
fn [0] := CHR (j);
fn := fn + name + ext;
check := checkpath (fn, INF_NODIR, drive, dir, name, ext, fn);
IF hasext <> 0
THEN BEGIN
IF (check AND FILE_EXISTS) <> 0
THEN found := hasext
ELSE found := 0;
END
ELSE found := tryext (fn);
END;
END;
findfile := found;
END; { findfile }
{>e
Get name and path of the command processor via the COMSPEC
environmnt variable. Any parameters after the program name
are copied and inserted into the command line.
<}
{>d
Namen und Pfad des Kommandoprozessors über die COMSPEC-Umgebungs-
Variable bestimmen. Parameter nach dem Programmnamen werden kopiert
und in die Kommandozeile eingefügt.
<}
PROCEDURE getcmdpath;
VAR
i, found : INTEGER;
BEGIN
IF LENGTH (cmdpath) > 0
THEN EXIT;
cmdpath := getenv ('COMSPEC');
cmdpars := '';
found := 0;
IF cmdpath <> ''
THEN BEGIN
i := 1;
WHILE (i <= LENGTH (cmdpath)) AND (cmdpath [i] IN spaces) DO
INC (i);
IF i > 1
THEN BEGIN
cmdpath := COPY (cmdpath, i, 255);
i := 1;
END;
i := strpbrk (cmdpath, ';,=+/"[]|<> '#9);
IF i <> 0
THEN BEGIN
cmdpars := COPY (cmdpath, i, 128);
cmdpath [0] := CHR (i - 1);
i := 1;
WHILE (i <= LENGTH (cmdpars)) AND (cmdpars [i] IN spaces) DO
INC (i);
IF i > 1
THEN cmdpars := COPY (cmdpars, i, 128);
IF cmdpars <> ''
THEN cmdpars := cmdpars + ' ';
END;
found := findfile (cmdpath);
END;
IF found = 0
THEN BEGIN
cmdpath := 'COMMAND.COM';
cmdpars := '';
found := findfile (cmdpath);
IF found = 0
THEN cmdpath := '';
END;
END;
FUNCTION tempdir (VAR outfn : filename) : BOOLEAN;
{ Set temporary file path.
Read "TMP/TEMP" environment. If empty or invalid, clear path.
If TEMP is drive or drive+backslash only, return TEMP.
Otherwise check if given path is a valid directory.
}
VAR
stmp : ARRAY [0..3] OF filename;
i, res : INTEGER;
BEGIN
stmp [0] := getenv ('TMP');
stmp [1] := getenv ('TEMP');
stmp [2] := '.\';
stmp [3] := '\';
FOR i := 0 TO 3 DO
IF LENGTH (stmp [i]) <> 0
THEN BEGIN
outfn := stmp [i];
res := checkpath (outfn, 0, drive, dir, name, ext, outfn);
IF (res > 0) AND ((res AND IS_DIR) <> 0) AND ((res AND IS_READ_ONLY) = 0)
THEN BEGIN
tempdir := TRUE;
EXIT;
END;
END;
tempdir := FALSE;
END;
{$IFDEF REDIRECT}
FUNCTION parse_redirect (VAR par : STRING; idx : INTEGER;
VAR stdin, stdout, stderr : pstring) : BOOLEAN;
VAR
ch : CHAR;
fnp : pstring;
fn : STRING;
app, i, beg, fne : INTEGER;
BEGIN
i := idx;
par [LENGTH (par) + 1] := #0;
REPEAT
app := 0;
ch := par [i];
beg := i;
i := i + 1;
IF ch <> '<'
THEN BEGIN
IF par [i] = '&'
THEN BEGIN
ch := '&';
INC (i);
END;
IF par [i] = '>'
THEN BEGIN
app := 1;
INC (i);
END;
END;
WHILE (i <= LENGTH (par)) AND (par [i] IN spaces) DO
INC (i);
fn := COPY (par, i, 255);
fne := strpbrk (fn, ';,=+/"[]|<> '#9);
IF fne = 0
THEN fne := LENGTH (fn) + 1;
par := COPY (par, 1, beg - 1) + COPY (fn, fne, 255);
i := beg;
fn [0] := CHR (fne - 1);
IF (fne = 0) OR (LENGTH (fn) = 0)
THEN BEGIN
parse_redirect := FALSE;
EXIT;
END;
GETMEM (fnp, LENGTH (fn) + app + 2);
IF fnp = NIL
THEN BEGIN
parse_redirect := FALSE;
EXIT;
END;
IF app <> 0
THEN fnp^ := '>' + fn
ELSE fnp^ := fn;
fnp^ [LENGTH (fnp^) + 1] := #0;
CASE ch OF
'<' : IF stdin <> NIL
THEN BEGIN
parse_redirect := FALSE;
EXIT;
END
ELSE stdin := fnp;
'>' : IF stdout <> NIL
THEN BEGIN
parse_redirect := FALSE;
EXIT;
END
ELSE stdout := fnp;
'&' : IF stderr <> NIL
THEN BEGIN
parse_redirect := FALSE;
EXIT;
END
ELSE stderr := fnp;
END;
i := strpbrk (fn, '<>');
UNTIL (i <= 0);
par [LENGTH (par) + 1] := #0;
parse_redirect := TRUE;
END;
{$ENDIF}
FUNCTION do_exec (xfn : STRING; pars : STRING; spawn : INTEGER;
needed : WORD; newenv : BOOLEAN) : INTEGER;
LABEL
EXIT;
VAR
cmdbat : INTEGER;
swapfn : filename;
avail : WORD;
regs : REGISTERS;
envlen, einx : WORD;
idx, len, rc : INTEGER;
envp : bytearrayptr;
swapping : INTEGER;
{$IFDEF REDIRECT}
stdin, stdout, stderr : pstring;
{$ENDIF}
BEGIN
{$IFDEF REDIRECT}
stdin := NIL; stdout := NIL; stderr := NIL;
{$ENDIF}
getcmdpath;
envlen := 0;
{ First, check if the file to execute exists. }
cmdbat := findfile (xfn);
IF cmdbat <= 0
THEN BEGIN
do_exec := RC_NOFILE OR - cmdbat;
GOTO EXIT;
END;
IF cmdbat > 1 { COMMAND.COM or Batch file }
THEN BEGIN
IF LENGTH (cmdpath) = 0
THEN BEGIN
do_exec := RC_NOFILE OR - ERR_COMSPEC;
GOTO EXIT;
END;
IF cmdbat = 2
THEN pars := cmdpars + '/c ' + xfn + ' ' + pars
ELSE pars := cmdpars + pars;
xfn := cmdpath;
END;
{$IFDEF REDIRECT}
idx := strpbrk (pars, '<>');
IF idx > 0
THEN IF NOT parse_redirect (pars, idx, stdin, stdout, stderr)
THEN BEGIN
do_exec := RC_REDIRERR;
GOTO EXIT;
END;
{$ENDIF}
{ Now create a copy of the environment if the user wants it, and
if the environment has been changed. }
IF newenv AND (envptr <> NIL)
THEN BEGIN
FOR idx := 0 TO envcnt - 1 DO
envlen := envlen + LENGTH (envptr^ [idx]^) + 1;
IF envlen > 0
THEN BEGIN
envlen := envlen + 1;
GETMEM (envp, envlen);
IF envp = NIL
THEN BEGIN
do_exec := RC_ENVERR;
GOTO EXIT;
END;
einx := 0;
FOR idx := 0 TO envcnt - 1 DO
BEGIN
len := LENGTH (envptr^ [idx]^);
MOVE (envptr^ [idx]^ [1], envp^ [einx], len);
envp^ [einx + len] := 0;
einx := einx + len + 1;
END;
envp^ [einx] := 0;
END;
END;
IF spawn = 0
THEN swapping := - 1
ELSE BEGIN
{ Determine amount of free memory }
WITH regs DO
BEGIN
ax := $4800;
bx := $ffff;
MSDOS (regs);
avail := regs.bx;
END;
{ No swapping if available memory > needed }
IF needed < avail
THEN swapping := 0
ELSE BEGIN
{ Swapping necessary, use 'TMP' or 'TEMP' environment variable
to determine swap file path if defined. }
swapping := spawn;
IF (spawn AND USE_FILE) <> 0
THEN BEGIN
IF NOT tempdir (swapfn)
THEN BEGIN
spawn := spawn XOR USE_FILE;
swapping := spawn;
END
ELSE BEGIN
IF (dosversion AND $ff) >= 3
THEN swapping := swapping OR CREAT_TEMP
ELSE BEGIN
swapfn := swapfn + swap_filename;
len := LENGTH (swapfn);
WHILE exists (swapfn) DO
BEGIN
IF (swapfn [len] >= 'Z')
THEN len := len - 1;
IF (swapfn [len] = '.')
THEN len := len - 1;
swapfn [len] := SUCC (swapfn [len]);
END;
END;
swapfn [LENGTH (swapfn) + 1] := #0;
END;
END;
END;
END;
{ All set up, ready to go. }
IF swapping > 0
THEN BEGIN
IF envlen = 0
THEN swapping := swapping OR DONT_SWAP_ENV;
rc := prep_swap (swapping, swapfn);
IF rc < 0
THEN BEGIN
do_exec := RC_PREPERR OR - rc;
GOTO EXIT;
END;
END;
xfn [LENGTH (xfn) + 1] := #0;
pars [LENGTH (pars) + 1] := #0;
IF @spawn_check <> NIL
THEN BEGIN
rc := spawn_check (cmdbat, swapping, xfn, pars);
IF rc <> 0
THEN BEGIN
do_exec := rc;
GOTO EXIT;
END;
END;
swapvectors;
{$IFDEF REDIRECT}
do_exec := do_spawn (swapping, xfn, pars, envlen, envp^, stdin, stdout, stderr);
{$ELSE}
do_exec := do_spawn (swapping, xfn, pars, envlen, envp^);
{$ENDIF}
swapvectors;
{ Free the environment buffer if it was allocated. }
EXIT :
IF envlen > 0
THEN FREEMEM (envp, envlen);
{$IFDEF REDIRECT}
IF stdin <> NIL
THEN FREEMEM (stdin, LENGTH (stdin^) + 2);
IF stdout <> NIL
THEN FREEMEM (stdout, LENGTH (stdout^) + 2);
IF stderr <> NIL
THEN FREEMEM (stderr, LENGTH (stderr^) + 2);
{$ENDIF}
END;
{ Initialisation for environment processing }
BEGIN
envptr := NIL;
envcnt := 0;
cmdpath := '';
@spawn_check := NIL;
END.
